COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00015 ENDMK
C⊗;

(STATUS 2 1 2)


(DE INITALL()

  (SETQ STACK (SETQ LLINK (LIST 'LLINK)))
  (SETQ ENV (MAPCAR '(L M N P Q R S U V W X Y Z)

                    '(LAMBDA (1X) (CONS 1X 'NODEF))))
  (NCONC ENV '((NIL . NIL) (T . T)))

  ENV)

;

(DF PROG (%B ;; %X %GO-LIST)
   (SETQ %B (CDR %B))
  (SETQ %GO-LIST (MAPT %B '(LAMBDA (%B)
       (AND (ATOM (CAR %B)) %B))))
  (WHILE %B
    (ESCAPE %LABEL (AND (LISTP (SETQ %X (NEXTL %B)))
                        (EVAL %X))))
  'OK-PROG)

(DF GO (%L) (GOTO (CAR %L)))

(DE GOTO (%L)
  (AND (SETQ %B (CASSQ %L %GO-LIST)) (%LABEL))
  (PRINT 'ERREUR-ETIQ %L 'JE 'BOUCLE)
  (WHILE T))
;

(DE SETVAL (1X 1Y) (RPLACD (ASSQ 1X ENV) 1Y))

(DE LIER ()
  (PUSH LLINK) (PUSH -1)
  (WHILE RX (PUSH (ATVAL (CAR RX))) (PUSH (CAR RX))
            (SETVAL (NEXTL RX) (NEXTL RY)))
  (PUSH 'LLINK)
  (SETQ LLINK STACK))



(DE DELIER ()
  (SETQ STACK (CDR LLINK))

  (WHILE (NEQ (CAR STACK) -1) (SETVAL (POP) (POP)))
  (POP) (SETQ LLINK (POP)))




(SYNONYM 'SIMREC 'AND)
(DE ATVAL (1X) (CASSQ 1X ENV))






(SETQ OKP NIL)
(DE PUSH (1X) (AND (> (LENGTH STACK) 1000) (PRINT 'ERR-FS)(GO ERREUR))
              (SETQ STACK (CONS 1X STACK)))


(DE POP () (NEXTL STACK))
  
(DF PUSHJ (1X) (PUSH (CADR 1X)) (GOTO (CAR 1X)))
  
(DE POPJ() (GOTO (POP)))

(DE INTERPR ()

 (PROG()
       (INITALL)
TOPLEVEL

      (PRINT 'TOPLEVEL-LOOP)
      (SETQ A1 (READ)) (PUSHJ EVAL TOP2)
  TOP2
      (PRINT A1) (GO TOPLEVEL)


;************************ EVAL **************************;

  EVALCAR
      (SETQ A1 (CAR A1))

  EVAL

      (IF OKP (PRINT 'LENGTH-STACK '= (LENGTH STACK)))
      (IF (NUMBP A1) (POPJ))

      (IF (LISTP A1) (GO EVAL1))
      ; CAS A1 ATOME ALPH ;
      (SETQ A2 (ATVAL A1))

      (IF (= A2 'NODEF) (PROGN

                          (PRINT 'ERR-A8 A1) (GO ERREUR))
          (SETQ A1 A2))
      (POPJ)

  EVAL1

      (IF (= (CAR A1) QUOTE) (PROGN (SETQ A1 (CADR A1)) (POPJ)))

      (SETQ F (CAR A1) A1 (CDR A1))
  EVAL2
      (IF (LISTP F) (GO EVAL3))
                                   ; CAS F ATOME ;
      (OR (NUMBP F) (GO EVAL21))
                                   ; CAS F NOMBRE : (N E)  ;
      (PUSH F) (PUSHJ EVLIS EVAL20)
  EVAL20
      (SETQ A2 (CAR A1) A1 (POP)) (GO CNTH)
  EVAL21
      (COND ((SETQ 1X (GET F 'INT)) (SETQ F 1X) (GO EVAL3)))

      (COND ((SETQ 1X (GET F 'FINT))
             (SETQ A4 [A1] A1 1X) (GO APPLYP)))
      (IF (= (TYPEFN F) SUBR) (GO EVAL5))
      (IF (= (TYPEFN F) FSUBR) (GOTO F)) ; LANCA FSUBRS EVAL ;
      (COND ((= (ATVAL F) F) (PRINT 'ERR-ID-EVAL F) (GO ERREUR)))
      (SETQ F (ATVAL F)) (GO EVAL2)
  EVAL5
      (PUSH F) (PUSHJ EVLIS EVAL6)
  EVAL6
      (SETQ A4 A1 F (POP))
  LANCE-SUBRS
      (SETQ A1 (CAR A4) A2 (CADR A4) A3 (CADDR A4)) (GOTO F)
  
  EVAL3
      (PUSH F) (PUSHJ EVLIS EVAL4)
  EVAL4
      (SETQ A4 A1 A1 (POP)) (GO APPLYP)

 ;                  $#%$#%$#%$#%$#% APPLY $#%$#%$#%$#%      ;

  APPLYP
      (IF (LISTP A1) (GO APPLY2))

      (OR (NUMBP A1) (GO APPLY1))

      (SETQ A2 (CAR A4)) (GO CNTH)
  APPLY1
      (COND ((SETQ 1X (GET A1 'INT)) (SETQ A1 1X) (GO APPLY2)))

      (COND ((SETQ 1X (GET A1 'FINT)) (SETQ A1 1X) (GO APPLY2)))
      (COND ((= (TYPEFN A1) SUBR) (SETQ F A1) (GO LANCE-SUBRS)))
      (COND ((= (TYPEFN A1) FSUBR) (SETQ F A1 A1 A4) (GOTO F)))
                                   ; LANCE FSUBRS APPLY ;
      (COND ((= (ATVAL A1) A1) (PRINT 'ERR-ID-APPLY A1)
                               (GO ERREUR)))
      (SETQ A1 (ATVAL A1)) (GO APPLYP)
  APPLY2
      (IF (NEQ (CAR A1) LAMBDA) (GO APPLY4))
      (SETQ RY A4 RX (CADR A1) A1 (CDDR A1))
  APPLY20
      (COND ((= A1 (CADR STACK))
             (WHILE RX (SETVAL (NEXTL RX) (NEXTL RY)))
             (GO PROGN)))
      (LIER) (PUSH A1) (PUSHJ PROGN APPLY3)
  APPLY3
      (POP) (DELIER) (POPJ)
  APPLY4
      (IF (= (CAR A1) 'GAMMA) (GO APPLY6))
      (PUSH A4) (PUSHJ EVAL APPLY5)
  APPLY5
      (SETQ A4 (POP)) (GO APPLYP)
                                     ; TYPE (GAMMA (X1...XN) E1...EN);
  APPLY6
      (SETQ RY (CAR A4) RX (CADR A1) A1 (CDDR A1)) (GO APPLY20)

;********************** PROGN *****************************;

  PROGN


      (OR (CDR A1) (GO EVALCAR))
      (PUSH (CDR A1))

      (PUSHJ EVALCAR PROGN2)
  PROGN2
      (SETQ A1 (POP))
      (GO PROGN)

 ;************************** IF *********************** ;

  IF

      (PUSH (CDR A1)) (PUSHJ EVALCAR IF2)


  IF2
      (SETQ A2 (POP))

      (IF A1 (PROGN (SETQ A1 (CAR A2)) (GO EVAL)))
      (SETQ A1 (CDR A2))
      (GO PROGN)


; ************************** EVLIS ******************************* ;

  EVLIS
      (OR A1 (POPJ))
      (SETQ A2 NIL)
  EVLIS2
      (PUSH A1) (PUSH A2) (PUSHJ EVALCAR EVLIS3)
  EVLIS3
      (SETQ A2 (CONS A1 (POP)) A1 (CDR (POP)))
      (IF A1 (GO EVLIS2))
      (SETQ A1 (REVERSE A2)) (POPJ)

; ************************* SETQ & NEXTL *************************;
  SETQ
      (PUSH A1) (SETQ A1 (CDR A1)) (PUSHJ EVALCAR SETQ1)
  SETQ1
      (SETQ A2 (POP)) (SETVAL (CAR A2) A1) (SETQ A2 (CDDR A2))
      (IF (NULL A2) (POPJ))
      (SETQ A1 A2) (GO SETQ)

  NEXTL
      (SETQ A2 (CAR A1) 1X (ATVAL A2) A1 (CAR 1X))
      (SETVAL A2 (CDR 1X)) (POPJ)

  ; *************************** COND **************************** ;
  COND
      (OR A1 (POPJ))
      (PUSH A1) (SETQ  A1 (CAR A1)) (PUSHJ EVALCAR COND1)
  COND1
      (SETQ A2 (POP))
      (IF A1 (SETQ A2 (CDAR A2))
             (SETQ A1 (CDR A2)) (GO COND))
      (IF A2 (SETQ A1 A2) (POPJ))
      (GO PROGN)


 ; ************************** SIMREC ******************************** ;


  ;  (SIMREC (FD1 ... FDN) E) , FD = (NOM LARGS E1...EN);

  SIMREC
      (SETQ A5 0 A2 (CADR A1) A1 (CAR A1))
  EVWITH1
      (OR A1 (GO EVWITH2))
      (SETQ A3 (NEXTL A1) RX [(SETQ 1X (NEXTL A3))]
            RY [(CONS LAMBDA A3)])
      (OR (ASSQ 1X ENV) (SETQ ENV (CONS (CONS 1X 'NODEF) ENV)))
      (LIER) (INCR A5) (GO EVWITH1)
  EVWITH2
      (SETQ A1 A2) (PUSH A5) (PUSHJ EVAL EVWITH3)
  EVWITH3

       (SETQ A5 (POP)) (WHILE (GZP A5) (DELIER) (DECR A5)) (POPJ)




 ; *********************** DE & DF *****************************;
  DE
      (PUT (CAR A1) (CONS LAMBDA (CDR A1)) 'INT)
      (SETQ A1 (CAR A1)) (POPJ)
  DF
      (PUT (CAR A1) (CONS LAMBDA (CDR A1)) 'FINT)
      (SETQ A1 (CAR A1)) (POPJ)

; *********************** SUBRS ******************************;


  ATOM
      (SETQ A1 (ATOM A1)) (POPJ)
  LISTP
      (SETQ A1 (LISTP A1)) (POPJ)
  READ
      (SETQ A1 (READ)) (POPJ)


  PRINT
      (APPLY 'PRINT A4) (POPJ)
  PRIN1
      (APPLY 'PRIN1 A4) (POPJ)
  TERPRI
      (TERPRI) (POPJ)

  CADDR
      (SETQ A1 (CDR A1))
  CADR
      (SETQ A1 (CDR A1))
  CAR
      (SETQ A1 (CAR A1)) (POPJ)
  CDDR
      (SETQ A1 (CDR A1))
  CDR
      (SETQ A1 (CDR A1)) (POPJ)
  NULL
      (SETQ A1 (NULL A1)) (POPJ)
  CONS
      (SETQ A1 (CONS A1 A2)) (POPJ)
  APPEND
      (SETQ A1 (APPEND A1 A2)) (POPJ)
  1+
      (SETQ A1 (1+ A1)) (POPJ)
  1-
      (SETQ A1 (1- A1)) (POPJ)
  =

      (SETQ A1 (= A1 A2)) (POPJ)
  +
      (SETQ A1 (APPLY '+ A4)) (POPJ)
  *
      (SETQ A1 (APPLY '* A4)) (POPJ)
  -
      (SETQ A1 (- A1 A2)) (POPJ)



  APPLY
      (SETQ A4 A2) (GO APPLYP)
  EQUAL
      (SETQ A1 (EQUAL A1 A2)) (POPJ)
  CNTH
      (SETQ A1 (CNTH A1 A2)) (POPJ)

  LIST
      (SETQ A1 A4) (POPJ)




; ****************************** ERREUR ****************************;
  ERREUR
      (SETQ STACK (SETQ LLINK (LIST 'LLINK)))
      (SETQ A1 (SETQ A2 (SETQ A3 (SETQ A4 NIL))))
      (GO TOPLEVEL)

 ; ********************* END OF INTERPR ************************;
))

(PROGN (STATUS 1 1 2) '(LOAD INTERPR))